home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / backend / optimize.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  77.3 KB  |  2,081 lines  |  [TEXT/CCL2]
  1. ;;; optimize.scm -- flic optimizer
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  7 May 1992
  5. ;;;
  6. ;;;
  7. ;;; The optimizer does these kinds of program transformations:
  8. ;;;
  9. ;;; * remove unreferenced variable bindings.
  10. ;;;
  11. ;;; * constant folding and various other kinds of compile-time
  12. ;;;   evaluation.
  13. ;;;
  14. ;;; * beta reduction (replace references to variables bound to simple
  15. ;;;   expressions with the expression)
  16. ;;; 
  17.  
  18.  
  19. ;;; Since some of the optimizations can make additional transformations
  20. ;;; possible, we want to make multiple iteration passes.  But since each
  21. ;;; pass is likely to have diminishing benefits, we don't want to keep
  22. ;;; iterating indefinitely.  So establish a fairly arbitrary cutoff point.
  23. ;;; The value is based on empirical results from compiling the prelude.
  24.  
  25. (define *max-optimize-iterations* 5)
  26. (define *optimize-foldr-iteration* 0)  ; when to inline foldr
  27. (define *optimize-build-iteration* 0)  ; when to inline build
  28. (define *current-optimize-iteration* 0)
  29.  
  30.  
  31. ;;; Flags for enabling various optimizations
  32.  
  33. (define *all-optimizers* '(foldr inline constant lisp delays))
  34. (define *optimizers* *all-optimizers*)
  35. (define *compiled-code-optimizers* *all-optimizers*)
  36. (define *interpreted-code-optimizers* '())
  37.  
  38.  
  39. ;;; Used to note whether we are doing the various optimizations
  40.  
  41. (define-local-syntax (do-optimization? o)
  42.   `(memq ,o (dynamic *optimizers*)))
  43.  
  44. (define *do-foldr-optimizations* (do-optimization? 'foldr))
  45. (define *do-inline-optimizations* (do-optimization? 'inline))
  46. (define *do-constant-optimizations* (do-optimization? 'constant))
  47.  
  48.  
  49. ;;; If the foldr optimization is enabled, bind the corresponding
  50. ;;; variables to these values instead of the defaults.
  51.  
  52. (define *foldr-max-optimize-iterations* 15)
  53. (define *foldr-optimize-foldr-iteration* 8)
  54. (define *foldr-optimize-build-iteration* 5)
  55.  
  56.  
  57. ;;; Some random other variables
  58.  
  59. (define *structured-constants* '())
  60. (define *structured-constants-table* '#f)
  61. (define *lambda-depth* 0)
  62. (define *local-bindings* '())
  63.  
  64.  
  65. ;;; This is for doing some crude profiling.  
  66. ;;; Comment out the body of the macro to disable profiling.
  67.  
  68. ;;; Here are current counts from compiling the prelude:
  69. ;;; (LET-REMOVE-UNUSED-BINDING . 7709)
  70. ;;; (REF-INLINE . 5532)
  71. ;;; (REF-INLINE-SINGLE-REF . 4736)
  72. ;;; (LET-EMPTY-BINDINGS . 4489)
  73. ;;; (APP-LAMBDA-TO-LET . 2712)
  74. ;;; (APP-HOIST-STRUCTURED-CONSTANT . 1371)
  75. ;;; (AND-UNARY . 1070)
  76. ;;; (CASE-BLOCK-DEAD-CODE . 625) 
  77. ;;; (SEL-FOLD-VAR . 608)
  78. ;;; (CASE-BLOCK-IDENTITY . 543)
  79. ;;; (APP-MAKE-SATURATED . 528)
  80. ;;; (LET-HOIST-RETURN-FROM . 505)
  81. ;;; (APP-HOIST-LET . 447)
  82. ;;; (AND-CONTAINS-TRUE . 412)
  83. ;;; (APP-FOLD-SELECTOR . 385)
  84. ;;; (CASE-BLOCK-TO-IF . 366)
  85. ;;; (AND-HOIST-STRICT2 . 349)
  86. ;;; (INTEGER-TO-INT-CONSTANT-FOLD . 349)
  87. ;;; (IS-CONSTRUCTOR-FOLD-TUPLE . 332)
  88. ;;; (CASE-BLOCK-HOIST-STRICT2 . 289)
  89. ;;; (LAMBDA-COMPRESS . 255)
  90. ;;; (FOLDR-INLINE . 212) 
  91. ;;; (AND-COMPRESS . 193)
  92. ;;; (BUILD-INLINE-LAMBDA . 193)
  93. ;;; (IF-FOLD . 182) 
  94. ;;; (LET-HOIST-LAMBDA . 164)
  95. ;;; (APP-COMPRESS . 156)
  96. ;;; (STRICT2-SEL-IDENTITY . 111)
  97. ;;; (LET-COMPRESS . 106)
  98. ;;; (IF-COMPRESS-TEST . 104)
  99. ;;; (IF-HOIST-LAMBDA . 100)
  100. ;;; (CASE-BLOCK-DISCARD-REDUNDANT-TEST . 99)
  101. ;;; (FOLDR-BUILD-IDENTITY . 95)
  102. ;;; (FOLDR-CONS-IDENTITY . 87)
  103. ;;; (FOLDR-PRIM-APPEND-INLINE . 83)
  104. ;;; (IF-HOIST-RETURN-FROM . 66)
  105. ;;; (FOLDR-NIL-IDENTITY . 48)
  106. ;;; (STRICT2-HOIST-RETURN-FROM . 40)
  107. ;;; (FOLDR-HOIST-LET . 35)
  108. ;;; (LET-HOIST-INVARIANT-ARGS . 33)
  109. ;;; (IF-IDENTITY-INVERSE . 27)
  110. ;;; (FOLDR-CONS-NIL-IDENTITY . 23)
  111. ;;; (CON-NUMBER-FOLD-TUPLE . 21)
  112. ;;; (CASE-BLOCK-HOIST-LET . 21)
  113. ;;; (INTEGER-TO-INT-IDENTITY . 13)
  114. ;;; (APP-PACK-IDENTITY . 8)
  115. ;;; (APP-SPECIALIZE . 6)
  116. ;;; (IF-IDENTITY . 4) 
  117. ;;; (CON-NUMBER-FOLD . 2)
  118. ;;; (LET-HOIST-STRUCTURED-CONSTANT . 2)
  119. ;;; (INT-TO-INTEGER-CONSTANT-FOLD . 1)
  120.  
  121.  
  122. (define-local-syntax (record-hack type . args)
  123.   (declare (ignore args))
  124.   `',type
  125. ;  `(record-hack-aux ,type ,@args)
  126.   )
  127.  
  128. (define *hacks-done* '())
  129.  
  130. (define (record-hack-aux type . args)
  131.   ;; *** debug
  132.   ;; (format '#t "~s ~s~%" type args)
  133.   (declare (ignore args))
  134.   (let ((stuff  (assq type (car (dynamic *hacks-done*)))))
  135.     (if stuff
  136.     (incf (cdr stuff))
  137.     (push (cons type 1) (car (dynamic *hacks-done*))))))
  138.  
  139. (define (total-hacks)
  140.   (let ((totals  '()))
  141.     (dolist (alist *hacks-done*)
  142.       (dolist (entry alist)
  143.     (let ((stuff  (assq (car entry) totals)))
  144.       (if stuff
  145.           (setf (cdr stuff) (+ (cdr stuff) (cdr entry)))
  146.           (push (cons (car entry) (cdr entry)) totals)))))
  147.     totals))
  148.  
  149.  
  150. ;;; This is the main entry point.
  151.  
  152. (define (optimize-top object)
  153.   (if (flic-void? object)
  154.       object
  155.       (begin
  156.     (initialize-magic-optimizers)
  157.     (dynamic-let ((*structured-constants*       '())
  158.               (*structured-constants-table* (make-table))
  159.               (*lambda-depth*               0)
  160.               (*local-bindings*             '())
  161.               (*do-inline-optimizations*
  162.                (do-optimization? 'inline))
  163.               (*do-constant-optimizations*
  164.                (do-optimization? 'constant))
  165.               (*max-optimize-iterations*
  166.                (if (do-optimization? 'foldr)
  167.                (dynamic *foldr-max-optimize-iterations*)
  168.                (dynamic *max-optimize-iterations*)))
  169.               (*optimize-foldr-iteration*
  170.                (if (do-optimization? 'foldr)
  171.                (dynamic *foldr-optimize-foldr-iteration*)
  172.                (dynamic *optimize-foldr-iteration*)))
  173.               (*optimize-build-iteration*
  174.                (if (do-optimization? 'foldr)
  175.                (dynamic *foldr-optimize-build-iteration*)
  176.                (dynamic *optimize-build-iteration*))))
  177.       (setf *hacks-done* '())
  178.       (dotimes (i (dynamic *max-optimize-iterations*))
  179.         (dynamic-let ((*current-optimize-iteration*  i))
  180.           (when (memq 'optimize-extra (dynamic *printers*))
  181.         (format '#t "~%Optimize pass ~s:" i)
  182.         (pprint object))
  183.           (push '() *hacks-done*)
  184.           (setf object (optimize-flic-let-aux object '#t))))
  185.       (setf (flic-let-bindings object)
  186.         (nconc (nreverse (dynamic *structured-constants*))
  187.                (flic-let-bindings object))))
  188.     (install-uninterned-globals (flic-let-bindings object))
  189.     (postoptimize object)
  190.     object)))
  191.  
  192. (define-flic-walker optimize (object))
  193.  
  194. ;;; debugging stuff
  195. ;;; 
  196. ;;; (define *duplicate-object-table* (make-table))
  197. ;;; 
  198. ;;; (define (new-optimize object)
  199. ;;;   (if (table-entry (dynamic *duplicate-object-table*) object)
  200. ;;;       (error "Duplicate object ~s detected." object)
  201. ;;;       (begin
  202. ;;;     (setf (table-entry (dynamic *duplicate-object-table*) object) '#t)
  203. ;;;     (old-optimize object))))
  204. ;;; 
  205. ;;; (lisp:setf (lisp:symbol-function 'old-optimize)
  206. ;;;        (lisp:symbol-function 'optimize))
  207. ;;; (lisp:setf (lisp:symbol-function 'optimize)
  208. ;;;         (lisp:symbol-function 'new-optimize))
  209.  
  210. (define (optimize-list objects)
  211.   (optimize-list-aux objects)
  212.   objects)
  213.  
  214. (define (optimize-list-aux objects)
  215.   (if (null? objects)
  216.       '()
  217.       (begin
  218.         (setf (car objects) (optimize (car objects)))
  219.     (optimize-list-aux (cdr objects)))))
  220.  
  221.  
  222. ;;; Compress nested lambdas.  This hack is desirable because saturating
  223. ;;; applications within the lambda body effectively adds additional 
  224. ;;; parameters to the function.
  225.  
  226. ;;; *** Maybe this should look for hoistable constant lambdas too.
  227.  
  228. (define-optimize flic-lambda (object)
  229.   (let ((vars  (flic-lambda-vars object)))
  230.     (dynamic-let ((*lambda-depth*   (1+ (dynamic *lambda-depth*)))
  231.           (*local-bindings* (cons vars (dynamic *local-bindings*))))
  232.       (dolist (var vars)
  233.     (setf (var-referenced var) 0))
  234.       (let ((new-body  (optimize (flic-lambda-body object))))
  235.     (setf (flic-lambda-body object) new-body)
  236.     (cond ((is-type? 'flic-lambda new-body)
  237.            (record-hack 'lambda-compress)
  238.            (setf (flic-lambda-vars object)
  239.              (nconc (flic-lambda-vars object)
  240.                 (flic-lambda-vars new-body)))
  241.            (setf (flic-lambda-body object) (flic-lambda-body new-body)))
  242.           ((and (is-strict2-app? new-body)
  243.             (is-type? 'flic-lambda (strict2-app-arg2 new-body)))
  244.            (record-hack 'lambda-compress-strict2)
  245.            (let ((inner  (strict2-app-arg2 new-body)))
  246.          (setf (flic-lambda-vars object)
  247.                (nconc (flic-lambda-vars object)
  248.                   (flic-lambda-vars inner)))
  249.          (setf (flic-lambda-body object)
  250.                (make-strict2-app
  251.             (strict2-app-arg1 new-body)
  252.             (flic-lambda-body inner)))))
  253.           (else
  254.            '#f))
  255.     object))))
  256.  
  257.  
  258. ;;; For let, first mark all variables as unused and check for "simple"
  259. ;;; binding values that permit beta reduction.  Then walk the subexpressions.
  260. ;;; Finally discard any bindings that are still marked as unused.
  261. ;;; *** This fails to detect unused recursive variables.
  262.  
  263. (define-optimize flic-let (object)
  264.   (optimize-flic-let-aux object '#f))
  265.  
  266. (define (optimize-flic-let-aux object toplevel?)
  267.   (let ((bindings      (flic-let-bindings object))
  268.     (recursive?    (flic-let-recursive? object)))
  269.     ;; *** This handling of *local-bindings* isn't quite right since
  270.     ;; *** it doesn't account for the sequential nature of bindings
  271.     ;; *** in a non-recursive let, but it's close enough.  We won't
  272.     ;; *** get any semantic errors, but it might miss a few optimizations.
  273.     (dynamic-let ((*local-bindings*
  274.             (if (and recursive? (not toplevel?))
  275.             (cons bindings (dynamic *local-bindings*))
  276.             (dynamic *local-bindings*))))
  277.       (optimize-flic-let-bindings bindings recursive? toplevel?)
  278.       (dynamic-let ((*local-bindings*
  279.               (if (and (not recursive?) (not toplevel?))
  280.               (cons bindings (dynamic *local-bindings*))
  281.               (dynamic *local-bindings*))))
  282.     (setf (flic-let-body object) (optimize (flic-let-body object))))
  283.       ;; Check for unused bindings and other rewrites.
  284.       ;; Only do this for non-toplevel lets.
  285.       (if toplevel?
  286.       object
  287.       (optimize-flic-let-rewrite object bindings recursive?)))))
  288.  
  289. (define (optimize-flic-let-bindings bindings recursive? toplevel?)
  290.   ;; Initialize
  291.   (dolist (var bindings)
  292.     (setf (var-referenced var) 0)
  293.     (setf (var-fn-referenced var) 0)
  294.     (when (is-type? 'flic-lambda (var-value var))
  295.       (dolist (v (flic-lambda-vars (var-value var)))
  296.     (setf (var-arg-invariant? v) '#t)
  297.     (setf (var-arg-invariant-value v) '#f))))
  298.   ;; Traverse value subforms
  299.   (do ((bindings bindings (cdr bindings)))
  300.       ((null? bindings) '#f)
  301.       (let* ((var  (car bindings))
  302.          (val  (var-value var)))
  303.     (if (and (is-type? 'flic-app val)
  304.          (dynamic *do-constant-optimizations*)
  305.          (let ((fn   (flic-app-fn val))
  306.                (args (flic-app-args val)))
  307.            (if recursive?
  308.                (structured-constant-app-recursive?
  309.              fn args bindings (list var))
  310.                (structured-constant-app? fn args))))
  311.         ;; Variable is bound to a structured constant.  If this
  312.         ;; isn't already a top-level binding, replace the value
  313.         ;; of the constant with a reference to a top-level variable
  314.         ;; that is in turn bound to the constant expression.
  315.         ;; binding to top-level if this is a new constant.
  316.         ;; *** Maybe we should also look for variables bound
  317.         ;; *** to lambdas, that can also be hoisted to top level.
  318.         (when (not toplevel?)
  319.           (multiple-value-bind (con args cvar)
  320.           (enter-structured-constant-aux val '#t)
  321.         (record-hack 'let-hoist-structured-constant)
  322.         (if cvar
  323.             (setf (var-value var) (make-flic-ref cvar))
  324.             (add-new-structured-constant var con args))))
  325.         (begin
  326.           ;; If this is a function that's a candidate for foldr/build
  327.           ;; optimization, stash the value away prior to
  328.           ;; inlining the calls.
  329.           ;; *** We might try to automagically detect functions
  330.           ;; *** that are candidates for these optimizations here,
  331.           ;; *** but have to watch out for infinite loops!
  332.           (when (and (var-inline? var)
  333.              (eqv? (the fixnum
  334.                     (dynamic *current-optimize-iteration*))
  335.                    (the fixnum
  336.                     (dynamic *optimize-build-iteration*)))
  337.              (is-type? 'flic-lambda val)
  338.              (or (is-foldr-or-build-app? (flic-lambda-body val))))
  339.         (setf (var-inline-value var) (copy-flic-top val)))
  340.           ;; Then walk value normally.
  341.           (let ((new-val  (optimize val)))
  342.         (setf (var-value var) new-val)
  343.         (setf (var-simple? var)
  344.               (or (var-inline? var)
  345.               (and (not (var-selector-fn? var))
  346.                    (can-inline?
  347.                  new-val
  348.                  (if recursive? bindings '())
  349.                  toplevel?))))))
  350.       ))))
  351.  
  352.  
  353. (define (is-foldr-or-build-app? exp)
  354.   (typecase exp
  355.     (flic-app
  356.      (let ((fn  (flic-app-fn exp)))
  357.        (and (is-type? 'flic-ref fn)
  358.         (or (eq? (flic-ref-var fn) (core-symbol "foldr"))
  359.         (eq? (flic-ref-var fn) (core-symbol "build"))))))
  360.     (flic-let
  361.      (is-foldr-or-build-app? (flic-let-body exp)))
  362.     (flic-ref
  363.      (let ((val  (var-value (flic-ref-var exp))))
  364.        (and val (is-foldr-or-build-app? val))))
  365.     (else
  366.      '#f)))
  367.  
  368.  
  369. (define (optimize-flic-let-rewrite object bindings recursive?)
  370.   ;; Delete unused variables from the list.
  371.   (setf bindings
  372.     (list-delete-if
  373.       (lambda (var)
  374.         (cond ((var-toplevel? var)
  375.            ;; This was a structured constant hoisted to top-level.
  376.            '#t)
  377.               ((eqv? (the fixnum (var-referenced var)) (the fixnum 0))
  378.            (record-hack 'let-remove-unused-binding var)
  379.            '#t)
  380.           ((eqv? (the fixnum (var-referenced var)) (the fixnum 1))
  381.            (setf (var-single-ref var) (dynamic *lambda-depth*))
  382.            '#f)
  383.           (else
  384.            (setf (var-single-ref var) '#f)
  385.            '#f)))
  386.       bindings))
  387.   ;; Add extra bindings for reducing functions with invariant
  388.   ;; arguments.  Hopefully some of the extra bindings will go
  389.   ;; away in future passes!
  390.   (setf (flic-let-bindings object)
  391.     (setf bindings (add-stuff-for-invariants bindings)))
  392.   ;; Look for other special cases.
  393.   (cond ((null? bindings)
  394.      ;; Simplifying the expression by getting rid of the LET may
  395.      ;; make it possible to do additional optimizations on the 
  396.      ;; next pass.
  397.      (record-hack 'let-empty-bindings)
  398.      (flic-let-body object))
  399.     ((is-type? 'flic-return-from (flic-let-body object))
  400.      ;; Hoist return-from outside of LET.  This may permit
  401.      ;; further optimizations by an enclosing case-block.
  402.      (record-hack 'let-hoist-return-from)
  403.      (let* ((body       (flic-let-body object))
  404.         (inner-body (flic-return-from-exp body)))
  405.        (setf (flic-return-from-exp body) object)
  406.        (setf (flic-let-body object) inner-body)
  407.        body))
  408.     ((and (not recursive?)
  409.           (is-type? 'flic-let (flic-let-body object))
  410.           (not (flic-let-recursive? (flic-let-body object))))
  411.      ;; This is purely to produce more compact code.
  412.      (record-hack 'let-compress)
  413.      (let ((body  (flic-let-body object)))
  414.        (setf (flic-let-bindings object)
  415.          (nconc bindings (flic-let-bindings body)))
  416.        (setf (flic-let-body object) (flic-let-body body))
  417.        object))
  418.     ((is-type? 'flic-lambda (flic-let-body object))
  419.      ;; Hoist lambda outside of LET.  This may permit
  420.      ;; merging of nested lambdas on a future pass.
  421.      (record-hack 'let-hoist-lambda)
  422.      (let* ((body       (flic-let-body object))
  423.         (inner-body (flic-lambda-body body)))
  424.        (setf (flic-lambda-body body) object)
  425.        (setf (flic-let-body object) inner-body)
  426.        body))
  427.     (else
  428.      object))
  429.   )
  430.  
  431. ;;; Look for constant-folding and structured constants here.
  432.  
  433. (define-optimize flic-app (object)
  434.   (optimize-flic-app-aux object))
  435.  
  436. (define (optimize-flic-app-aux object)
  437.   (let ((new-fn   (optimize (flic-app-fn object)))
  438.     (new-args (optimize-list (flic-app-args object))))
  439.     (typecase new-fn
  440.       (flic-ref
  441.        ;; The function is a variable.
  442.        (let* ((var    (flic-ref-var new-fn))
  443.           (val    (var-value var))
  444.           (n      (length new-args))
  445.           (arity  (guess-function-arity var))
  446.           (magic  '#f))
  447.      (cond ((and (setf magic (var-specializers var))
  448.              (or (eqv? (dynamic *current-optimize-iteration*) 0)
  449.              (var-toplevel? var)))
  450.         ;; Try to replace call to generic function with call to
  451.         ;; specialized version.
  452.         ;; For locally defined functions, do this only on the initial
  453.         ;; pass through the optimizer, because otherwise we may end up
  454.         ;; generating calls to other local functions that have been
  455.         ;; optimized away on a previous pass.
  456.         (multiple-value-bind (fn args)
  457.             (try-to-specialize new-fn new-args magic)
  458.           (setf new-fn fn)
  459.           (setf new-args args)))
  460.            ((and arity (< (the fixnum n) (the fixnum arity)))
  461.         ;; This is a first-class call that is not fully saturated.
  462.         ;; Make it saturated by wrapping a lambda around it.
  463.         (setf new-fn
  464.               (do-app-make-saturated object new-fn new-args arity n))
  465.         (setf new-args '()))
  466.            ((var-selector-fn? var)
  467.         ;; This is a saturated call to a selector.  We might
  468.         ;; be able to inline the call.
  469.         (multiple-value-bind (fn args)
  470.             (try-to-fold-selector var new-fn new-args)
  471.           (setf new-fn fn)
  472.           (setf new-args args)))
  473.            ((and (not (var-toplevel? var))
  474.              (is-type? 'flic-lambda val))
  475.         ;; This is a saturated call to a local function.
  476.         ;; Increment its reference count and note if any of
  477.         ;; the arguments are invariant.
  478.         (incf (var-fn-referenced var))
  479.         (note-invariant-args new-args (flic-lambda-vars val)))
  480.            ((setf magic (magic-optimize-function var))
  481.         ;; Do special-purpose constant-folding, etc.
  482.         (multiple-value-bind (fn args)
  483.             (funcall magic new-fn new-args)
  484.           (setf new-fn fn)
  485.           (setf new-args args)))
  486.            )))
  487.       (flic-lambda
  488.        ;; Turn application of lambda into a let.
  489.        (multiple-value-bind (fn args)
  490.        (do-lambda-to-let-aux new-fn new-args)
  491.      (setf new-fn fn)
  492.      (setf new-args args)))
  493.       (flic-pack
  494.        (let ((con  (flic-pack-con new-fn))
  495.          (temp '#f))
  496.      (when (eqv? (length new-args) (con-arity con))
  497.        (cond ((and (dynamic *do-constant-optimizations*)
  498.                (every-1 (function structured-constant?) new-args))
  499.           ;; This is a structured constant that
  500.           ;; can be replaced with a top-level binding.
  501.           (setf (flic-app-fn object) new-fn)
  502.           (setf (flic-app-args object) new-args)
  503.           (record-hack 'app-hoist-structured-constant object)
  504.           (setf new-fn (enter-structured-constant object '#t))
  505.           (setf new-args '()))
  506.          ((and (setf temp (is-selector? con 0 (car new-args)))
  507.                (is-selector-list? con 1 temp (cdr new-args)))
  508.           ;; This is an expression like (cons (car x) (cdr x)).
  509.           ;; Replace it with just plain x to avoid reconsing.
  510.           (record-hack 'app-pack-identity new-fn)
  511.           (setf new-fn (copy-flic-top temp))
  512.           (setf new-args '()))
  513.          ))))
  514.       (flic-let
  515.        ;; Hoist let to surround entire application.
  516.        ;; Simplifying the function being applied may permit further
  517.        ;; optimizations on next pass.
  518.        ;; (We might try to hoist lets in the argument expressions, too,
  519.        ;; but I don't think that would lead to any real simplification
  520.        ;; of the code.)
  521.        (record-hack 'app-hoist-let)
  522.        (setf (flic-app-fn object) (flic-let-body new-fn))
  523.        (setf (flic-app-args object) new-args)
  524.        (setf new-args '())
  525.        (setf (flic-let-body new-fn) object)
  526.        )
  527.       (flic-app
  528.        ;; Try to compress nested applications.
  529.        ;; This may make the call saturated and permit further optimizations
  530.        ;; on the next pass.
  531.        (record-hack 'app-compress)
  532.        (setf new-args (nconc (flic-app-args new-fn) new-args))
  533.        (setf new-fn (flic-app-fn new-fn)))
  534.       )
  535.     (if (null? new-args)
  536.     new-fn
  537.     (begin
  538.       (setf (flic-app-fn object) new-fn)
  539.       (setf (flic-app-args object) new-args)
  540.       object))
  541.     ))
  542.  
  543. (define (guess-function-arity var)
  544.   (or (let ((value  (var-value var)))
  545.     (and value
  546.          (is-type? 'flic-lambda value)
  547.          (length (flic-lambda-vars value))))
  548.       (var-arity var)))
  549.  
  550. (define (do-app-make-saturated app fn args arity nargs)
  551.   (declare (type fixnum arity nargs))
  552.   (record-hack 'app-make-saturated fn args)
  553.   (let ((newvars  '())
  554.     (newargs  '()))
  555.     (dotimes (i (- arity nargs))
  556.       (declare (type fixnum i))
  557.       (let ((v  (init-flic-var (create-temp-var 'arg) '#f '#f)))
  558.     (push v newvars)
  559.     (push (make-flic-ref v) newargs)))
  560.     (setf (flic-app-fn app) fn)
  561.     (setf (flic-app-args app) (nconc args newargs))
  562.     (make-flic-lambda newvars app)))
  563.  
  564.  
  565.  
  566. ;;; If the function is a selector applied to a literal dictionary,
  567. ;;; inline it.
  568.  
  569. (define (try-to-fold-selector var new-fn new-args)
  570.   (let ((exp  (car new-args)))
  571.     (if (or (and (is-type? 'flic-ref exp)
  572.          ;; *** should check that var is top-level?
  573.          (is-bound-to-constructor-app? (flic-ref-var exp)))
  574.         (and (is-type? 'flic-app exp)
  575.          (is-constructor-app-prim? exp)))
  576.     (begin
  577.       (record-hack 'app-fold-selector)
  578.       (setf new-fn (copy-flic-top (var-value var)))
  579.       (do-lambda-to-let-aux new-fn new-args))
  580.     (values new-fn new-args))))
  581.  
  582.  
  583.  
  584. ;;; Try to pattern match to do generic-to-specific specialization.
  585. ;;; The specializers are an a-list of (special-fn . lambda) pairs.
  586. ;;; Choose the first one that matches.
  587.  
  588.  
  589. (define (try-to-specialize fn args specializers)
  590.   (if (null? specializers)
  591.       (values fn args)
  592.       (let* ((s      (car specializers))
  593.          (var    (car s))
  594.          (lambda (cdr s)))
  595.     (if (null? lambda)
  596.       ;; Ignore anything with a null pattern.
  597.       (try-to-specialize fn args (cdr specializers))
  598.       ;; Normal case.
  599.       (let* ((vars   (flic-lambda-vars lambda))
  600.          (app    (flic-lambda-body lambda))
  601.          (pat    (flic-app-args app)))
  602.         (multiple-value-bind (new-fn new-args)
  603.         (try-to-specialize-1 var args vars pat '())
  604.           (if new-fn
  605.           (values new-fn new-args)
  606.           (try-to-specialize fn args (cdr specializers)))))
  607.       ))))
  608.  
  609.  
  610. (define (try-to-specialize-1 new-fn-var actual-args vars pattern-args alist)
  611.   (let ((arg   '#f)
  612.     (var   '#f))
  613.     (cond ((null? pattern-args)
  614.        ;; Match successful!
  615.        (record-hack 'app-specialize new-fn-var)
  616.        (incf (var-referenced new-fn-var))
  617.        (values
  618.         (make-flic-ref new-fn-var)
  619.         (nconc
  620.           (map (lambda (v)
  621.              (let ((stuff  (assq v alist)))
  622.                (if stuff
  623.                (copy-flic-top (cdr stuff))
  624.                (error "Bad specializer for ~s!" new-fn-var))))
  625.            vars)
  626.           actual-args)))
  627.       ((null? actual-args)
  628.        ;; Match failed; call is not saturated.
  629.        (values '#f '()))
  630.       ((and (flic-ref? (setf arg (car pattern-args)))
  631.         (memq (setf var (flic-ref-var arg)) vars))
  632.        ;; This is one of the variables in the pattern.  Make sure
  633.        ;; we don't have it bound to two different things, then
  634.        ;; go on to match the next argument in the pattern.
  635.        (let ((match  (assq var alist)))
  636.          (cond ((not match)
  637.             (try-to-specialize-1
  638.               new-fn-var
  639.               (cdr actual-args)
  640.               vars
  641.               (cdr pattern-args)
  642.               (cons (cons var (car actual-args)) alist)))
  643.            ((flic-exp-eq? (cdr match) (car actual-args))
  644.             (try-to-specialize-1
  645.               new-fn-var
  646.               (cdr actual-args)
  647.               vars
  648.               (cdr pattern-args)
  649.               alist))
  650.            (else
  651.             (values '#f '())))))
  652.       ((flic-exp-eq? arg (car actual-args))
  653.        ;; The actual argument matches the literal pattern exactly.
  654.        (try-to-specialize-1
  655.          new-fn-var
  656.          (cdr actual-args)
  657.          vars
  658.          (cdr pattern-args)
  659.          alist))
  660.       (else
  661.        ;; Match failed; actual arguments don't match pattern.
  662.        (values '#f '()))
  663.       )))
  664.  
  665.  
  666. ;;; Various primitive functions have special optimizer functions
  667. ;;; associated with them, that do constant folding and certain
  668. ;;; other identities.  The optimizer function is called with the 
  669. ;;; function expression and list of argument expressions (at least
  670. ;;; as many arguments as the arity of the function) and should return
  671. ;;; the two values.
  672. ;;; This table has to be initialized in this weird way because the
  673. ;;; core-symbols aren't defined when this file is loaded.
  674.  
  675. (define *magic-optimizer-table* '#f)
  676.  
  677. (define (magic-optimize-function v)
  678.   (table-entry *magic-optimizer-table* v))
  679.  
  680. (define-syntax (set-magic-optimizer name function-name)
  681.   `(setf (table-entry *magic-optimizer-table* (core-symbol ,name))
  682.      (function ,function-name)))
  683.  
  684. (define (initialize-magic-optimizers)
  685.   (when (not *magic-optimizer-table*)
  686.     (setf *magic-optimizer-table* (make-table))
  687.     (set-magic-optimizer "foldr" optimize-foldr-aux)
  688.     (set-magic-optimizer "build" optimize-build)
  689.     (set-magic-optimizer "primIntegerToInt" optimize-integer-to-int)
  690.     (set-magic-optimizer "primIntToInteger" optimize-int-to-integer)
  691.     (set-magic-optimizer "primRationalToFloat" optimize-rational-to-float)
  692.     (set-magic-optimizer "primRationalToDouble" optimize-rational-to-double)
  693.     (set-magic-optimizer "primNegInt" optimize-neg)
  694.     (set-magic-optimizer "primNegInteger" optimize-neg)
  695.     (set-magic-optimizer "primNegFloat" optimize-neg)
  696.     (set-magic-optimizer "primNegDouble" optimize-neg)
  697.     (set-magic-optimizer "strict2" optimize-strict2)
  698.     (set-magic-optimizer ">>=" optimize-thenio)
  699.     (set-magic-optimizer ">>" optimize-thenio)
  700.     (set-magic-optimizer "applyIO" optimize-applyio)
  701.     ))
  702.  
  703.  
  704. ;;; Foldr identities for deforestation
  705.  
  706. (define (optimize-foldr fn args)
  707.   (multiple-value-bind (fn args)
  708.       (optimize-foldr-aux fn args)
  709.     (maybe-make-app fn args)))
  710.  
  711. (define (optimize-foldr-aux fn args)
  712.   (let ((k     (car args))
  713.     (z     (cadr args))
  714.     (l     (caddr args))
  715.     (tail  (cdddr args)))
  716.     (cond ((and (is-type? 'flic-pack k)
  717.         (eq? (flic-pack-con k) (core-symbol ":"))
  718.         (is-type? 'flic-pack z)
  719.         (eq? (flic-pack-con z) (core-symbol "Nil")))
  720.        ;; foldr (:) [] l ==> l
  721.        ;; (We arrange for build to be inlined before foldr
  722.        ;; so that this pattern can be detected.)
  723.        (record-hack 'foldr-cons-nil-identity)
  724.        (values l tail))
  725.       ((and (is-type? 'flic-app l)
  726.         (is-type? 'flic-ref (flic-app-fn l))
  727.         (eq? (flic-ref-var (flic-app-fn l))
  728.              (core-symbol "build"))
  729.         (null? (cdr (flic-app-args l))))
  730.        ;; foldr k z (build g) ==> g k z
  731.        (record-hack 'foldr-build-identity)
  732.        (values
  733.          (car (flic-app-args l))
  734.          (cons k (cons z tail))))
  735.       ((and (is-type? 'flic-pack l)
  736.         (eq? (flic-pack-con l) (core-symbol "Nil")))
  737.        ;; foldr k z [] ==> z
  738.        (record-hack 'foldr-nil-identity)
  739.        (values z tail))
  740.       ((short-string-constant? l)
  741.        ;; If the list argument is a string constant, expand it inline.
  742.        ;; Only do this if the string is fairly short, though.
  743.        (optimize-foldr-aux
  744.          fn
  745.          (cons k (cons z (cons (expand-string-constant l) tail)))))
  746.       ((and (is-type? 'flic-app l)
  747.         (is-type? 'flic-pack (flic-app-fn l))
  748.         (eq? (flic-pack-con (flic-app-fn l)) (core-symbol ":"))
  749.         (eqv? (length (flic-app-args l)) 2))
  750.        ;; foldr k z x:xs ==> let c = k in c x (foldr c z xs)
  751.        (record-hack 'foldr-cons-identity)
  752.        (let ((x     (car (flic-app-args l)))
  753.          (xs    (cadr (flic-app-args l))))
  754.          (values 
  755.            (if (can-inline? k '() '#f)
  756.            (do-foldr-cons-identity k z x xs)
  757.            (let ((cvar  (init-flic-var (create-temp-var 'c) k '#f)))
  758.              (make-flic-let
  759.                (list cvar)
  760.                (do-foldr-cons-identity (make-flic-ref cvar) z x xs)
  761.                '#f)))
  762.            tail)))
  763.       ((is-type? 'flic-let l)
  764.        ;; foldr k z (let bindings in body) ==>
  765.        ;;   let bindings in foldr k z body
  766.        (record-hack 'foldr-hoist-let)
  767.        (setf (flic-let-body l)
  768.          (optimize-foldr fn (list k z (flic-let-body l))))
  769.        (values l tail))
  770.       ((not (eqv? (the fixnum (dynamic *current-optimize-iteration*))
  771.               (the fixnum (dynamic *optimize-foldr-iteration*))))
  772.        ;; Hope for more optimizations later.
  773.        (values fn args))
  774.       ((and (is-type? 'flic-pack k)
  775.         (eq? (flic-pack-con k) (core-symbol ":")))
  776.        ;; Inline to special case, highly optimized append primitive.
  777.        ;; Could also look for (++ (++ l1 l2) l3) => (++ l1 (++ l2 l3))
  778.        ;; here, but I don't think that happens very often.
  779.            (record-hack 'foldr-prim-append-inline)
  780.        (values
  781.          (make-flic-ref (core-symbol "primAppend"))
  782.          (cons l (cons z tail))))
  783.       (else
  784.        ;; Default inline.
  785.        (record-hack 'foldr-inline k z)
  786.        (let ((new-fn
  787.            (copy-flic-top
  788.              (or (var-inline-value (core-symbol "inlineFoldr"))
  789.              (var-value (core-symbol "inlineFoldr"))
  790.              (error "Can't find inlineFoldr!")))))
  791.          (if (is-type? 'flic-lambda new-fn)
  792.          (do-lambda-to-let-aux new-fn args)
  793.          (values new-fn args))))
  794.       )))
  795.  
  796.  
  797. ;;; Mess with compile-time expansion of short string constants.
  798.  
  799. (define-integrable max-short-string-length 3)
  800.  
  801. (define (short-string-constant? l)
  802.   (and (is-type? 'flic-const l)
  803.        (let ((string  (flic-const-value l)))
  804.      (and (string? string)
  805.           (<= (the fixnum (string-length string))
  806.           (the fixnum max-short-string-length))))))
  807.  
  808. (define (expand-string-constant l)
  809.   (let* ((string  (flic-const-value l))
  810.      (length  (string-length string)))
  811.     (expand-string-constant-aux string 0 length)))
  812.  
  813. (define (expand-string-constant-aux string i length)
  814.   (declare (type fixnum i length))
  815.   (if (eqv? i length)
  816.       (make-flic-pack (core-symbol "Nil"))
  817.       (make-flic-app
  818.         (make-flic-pack (core-symbol ":"))
  819.     (list (make-flic-const (string-ref string i))
  820.           (expand-string-constant-aux string (+ 1 i) length))
  821.     '#f)))
  822.  
  823.  
  824. ;;; Helper function for the case of expanding foldr applied to cons call.
  825.  
  826. (define (do-foldr-cons-identity c z x xs)
  827.   (make-flic-app
  828.     c
  829.     (list x
  830.       (optimize-foldr
  831.         (make-flic-ref (core-symbol "foldr"))
  832.         (list (copy-flic-top c) z xs)))
  833.     '#f))
  834.  
  835.  
  836.  
  837. ;;; Short-circuit build inlining for the usual case where the
  838. ;;; argument is a lambda.  (It would take several optimizer passes
  839. ;;; for this simplification to fall out, otherwise.)
  840.  
  841. (define (optimize-build fn args)
  842.   (let ((arg  (car args)))
  843.     (cond ((not (eqv? (dynamic *current-optimize-iteration*)
  844.               (dynamic *optimize-build-iteration*)))
  845.        (valtrict2 exp (sel exp)) => (sel exp)
  846.        ;; since flic-sel always forces exp
  847.        (record-hack 'strict2-sel-identity)
  848.        (values arg2 (cddr args)))
  849.       ((and (is-type? 'flic-ref arg1)
  850.         (var-force-strict? (flic-ref-var arg1)))
  851.        ;; The variable is already going to be marked strict
  852.        (record-hack 'strict2-already-strict-identity)
  853.        (values arg2 (cddr args)))
  854.       (else
  855.        (values fn args)))))
  856.  
  857.  
  858. ;;; IO system identities.
  859. ;;; The idea is to supply the missing state argument, so that
  860. ;;;   (>>=) p q s ==>  applyIO (p s) (\ x -> q (getIOResult x) s)
  861. ;;;   (>>)  p q s ==>  applyIO (p s) (\ x -> q s)
  862. ;;; The code generator also knows about applyIO and expands the
  863. ;;; nested lambda into a LET*.
  864.  
  865. (define (optimize-thenio fn args)
  866.   (let* ((p   (car args))
  867.      (q   (cadr args))
  868.      (s   (caddr args))
  869.      (sv  (init-flic-var (create-temp-var 's) s '#f))
  870.      (xv  (init-flic-var (create-temp-var 'x) '#f '#f)))
  871.     ;; Tweak the magic bit to make sure xv is strict even if it's never used.
  872.     (setf (var-force-strict? xv) '#t)
  873.     (record-hack 'thenio-expand)
  874.     (values
  875.       (make-flic-let
  876.         (list sv)
  877.     (make-flic-app
  878.       (make-flic-ref (core-symbol "applyIO"))
  879.       (list
  880.         (make-flic-app p (list (make-flic-ref sv)) '#f)
  881.         (make-flic-lambda
  882.           (list xv)
  883.           (if (eq? (flic-ref-var fn) (core-symbol ">>="))
  884.           (make-flic-app
  885.             q
  886.             (list
  887.               (make-flic-app
  888.                 (make-flic-ref (core-symbol "getIOResult"))
  889.             (list (make-flic-ref xv))
  890.             '#f)
  891.               (make-flic-ref sv))
  892.             '#f)
  893.           (make-flic-app
  894.             q (list (make-flic-ref sv)) '#f))))
  895.       '#f)
  896.     '#f)
  897.       (cdddr args))))
  898.  
  899.  
  900. ;;; Look for monad identity
  901. ;;;   applyIO (applyIO p (\x1 -> q)) (\x2 -> r)  ====>
  902. ;;;   applyIO p (\x1 -> (applyIO q (\x2 -> r)))
  903. ;;; since the second form generates better code.
  904. ;;; Note that this identity can be applied recursively to the nested
  905. ;;; applyIO call.  
  906.  
  907. (define (optimize-applyio fn args)
  908.   (let ((arg1  (car args))
  909.     (arg2  (cadr args)))
  910.     (cond ((not (is-type? 'flic-lambda arg2))
  911.        (record-hack 'applyio-lambda)
  912.        (let ((xv  (init-flic-var (create-temp-var 'x) '#f '#f)))
  913.          (setf (var-force-strict? xv) '#t)
  914.          (setf arg2
  915.            (make-flic-lambda
  916.             (list xv)
  917.             (make-flic-app arg2 (list (make-flic-ref xv)) '#f))))
  918.        (values fn (cons arg1 (cons arg2 (cddr args)))))
  919.       ((and (is-type? 'flic-app arg1)
  920.         (is-type? 'flic-ref (flic-app-fn arg1))
  921.         (eq? (flic-ref-var (flic-app-fn arg1))
  922.              (core-symbol "applyIO")))
  923.        (do-applyio-identity fn arg1 arg2 (cddr args)))
  924.       (else
  925.        (values fn args)))))
  926.  
  927. (define (do-applyio-identity fn arg1 arg2 rest)
  928.   (record-hack 'applyio-identity)
  929.   (let* ((p  (car (flic-app-args arg1)))
  930.      (l  (cadr (flic-app-args arg1)))
  931.      (q  (flic-lambda-body l)))
  932.     ;; Mung the args to the nested applyIO app
  933.     (multiple-value-bind (nested-fn nested-args)
  934.     (optimize-applyio
  935.       (flic-app-fn arg1)
  936.       (cons q (cons arg2 (cddr (flic-app-args arg1)))))
  937.       (setf (flic-app-fn arg1) nested-fn)
  938.       (setf (flic-app-args arg1) nested-args))
  939.     ;; Munge the lambda
  940.     (setf (flic-lambda-body l) arg1)
  941.     ;; Return the new arguments
  942.     (values fn (cons p (cons l rest)))))
  943.  
  944.  
  945.  
  946. ;;; Convert lambda applications to lets.
  947. ;;; If application is not saturated, break it up into two nested
  948. ;;; lambdas before doing the transformation.
  949. ;;; It's better to do this optimization immediately than hoping
  950. ;;; the call will become fully saturated on the next pass.
  951. ;;; Maybe we could also look for a flic-let with a flic-lambda as
  952. ;;; the body to catch the cases where additional arguments can
  953. ;;; be found on a later pass.
  954.  
  955. (define (do-lambda-to-let new-fn new-args)
  956.   (multiple-value-bind (fn args)
  957.       (do-lambda-to-let-aux new-fn new-args)
  958.     (maybe-make-app fn args)))
  959.  
  960. (define (maybe-make-app fn args)
  961.   (if (null? args)
  962.       fn
  963.       (make-flic-app fn args '#f)))
  964.  
  965. (define (do-lambda-to-let-aux new-fn new-args)
  966.   (let ((vars     (flic-lambda-vars new-fn))
  967.     (body     (flic-lambda-body new-fn))
  968.     (matched  '()))
  969.     (record-hack 'app-lambda-to-let)
  970.     (do ()
  971.     ((or (null? new-args) (null? vars)))
  972.     (let ((var  (pop vaon ~s in and expression!" exp))))
  973.           ((is-type? 'flic-and exp)
  974.            ;; Flatten nested ands.
  975.            (record-hack 'and-compress)
  976.            (optimize-and-exps
  977.         (cdr exps)
  978.         (nconc (nreverse (flic-and-exps exp)) result)))
  979.           ((is-strict2-app? exp)
  980.            ;; Hoist strict2.  This helps with simplifying is-constructor
  981.                ;; tests on tuples without losing strictness properties.
  982.            (record-hack 'and-hoist-strict2)
  983.            (list (make-strict2-app
  984.                (strict2-app-arg1 exp)
  985.                (make-flic-and
  986.              (optimize-and-exps
  987.                (cons (strict2-app-arg2 exp) (cdr exps))
  988.                result)))))
  989.           (else
  990.            ;; No optimization possible.
  991.            (optimize-and-exps (cdr exps) (cons exp result)))
  992.           ))))
  993.  
  994.  
  995. (define (make-strict2-app arg1 arg2)
  996.   (make-flic-app
  997.     (make-flic-ref (core-symbol "strict2"))
  998.     (list arg1 arg2)
  999.     '#f))
  1000.  
  1001. (define (strict2-app-arg1 exp)
  1002.   (car (flic-app-args exp)))
  1003.  
  1004. (define (strict2-app-arg2 exp)
  1005.   (cadr (flic-app-args exp)))
  1006.  
  1007. (define (is-strict2-app? exp)
  1008.   (and (is-type? 'flic-app exp)
  1009.        (let ((fn    (flic-app-fn exp)))
  1010.      (and (is-type? 'flic-ref fn)
  1011.           (eq? (flic-ref-var fn) (core-symbol "strict2"))
  1012.           (null? (cddr (flic-app-args exp)))))))
  1013.  
  1014.  
  1015.  
  1016. ;;; Case-block optimizations.  These optimizations are possible because
  1017. ;;; of the restricted way this construct is used;  return-froms are
  1018. ;;; never nested, etc.
  1019.  
  1020. (define-optimize flic-case-block (object)
  1021.   (let* ((sym  (flic-case-block-block-name object))
  1022.      (exps (optimize-case-block-exps
  1023.          sym (flic-case-block-exps object) '())))
  1024.     (optimize-flic-case-block-aux object sym exps)))
  1025.  
  1026. (define (optimize-flic-case-block-aux object sym exps)
  1027.   (cond ((null? exps)
  1028.      ;; This should never happen.  It means all of the tests were
  1029.      ;; optimized away, including the failure case!
  1030.      (error "No exps left in case block ~s!" object))
  1031.     ((and (is-type? 'flic-and (car exps))
  1032.           (is-return-from-block?
  1033.             sym
  1034.             (car (last (flic-and-exps (car exps))))))
  1035.      ;; The first clause is a simple and.  Hoist it out of the
  1036.      ;; case-block and rewrite as if/then/else.
  1037.      (record-hack 'case-block-to-if)
  1038.      (let ((then-exp  (car (last (flic-and-exps (car exps))))))
  1039.        (setf (flic-case-block-exps object) (cdr exps))
  1040.        (make-flic-if
  1041.          (maybe-simplify-and
  1042.            (car exps)
  1043.            (butlast (flic-and-exps (car exps))))
  1044.          (flic-return-from-exp then-exp)
  1045.          (optimize-flic-case-block-aux object sym (cdr exps)))))
  1046.     ((is-return-from-block? sym (car exps))
  1047.      ;; Do an identity reduction.
  1048.      (record-hack 'case-block-identity)
  1049.      (flic-return-from-exp (car exps)))
  1050.     ((is-type? 'flic-let (car exps))
  1051.      ;; The first clause is a let.  Since this clause is going
  1052.      ;; to be executed anyway, hoisting the bindings to surround
  1053.      ;; the entire case-block should not change their strictness
  1054.      ;; properties, and it may permit some further optimizations.
  1055.      (record-hack 'case-block-hoist-let)
  1056.      (let* ((exp  (car exps))
  1057.         (body (flic-let-body exp)))
  1058.        (setf (flic-let-body exp)
  1059.          (optimize-flic-case-block-aux
  1060.            object sym (cons body (cdr exps))))
  1061.        exp))
  1062.     ((is-strict2-app? (car exps))
  1063.      ;; The first clause is a strict2.  Hoist this to surround the
  1064.      ;; entire case-block.
  1065.      (record-hack 'case-block-hoist-strict2)
  1066.      (let* ((exp  (car exps))
  1067.         (arg1 (strict2-app-arg1 exp))
  1068.         (arg2 (strict2-app-arg2 exp)))
  1069.        (setf (flic-case-block-exps object) (cons arg2 (cdr exps)))
  1070.        (make-strict2-app arg1 object)))
  1071.     (else
  1072.      (setf (flic-case-block-exps object) exps)
  1073.      object)
  1074.     ))
  1075.  
  1076.  
  1077. (define (optimize-case-block-exps sym exps result)
  1078.   (if (null? exps)
  1079.       (nreverse result)
  1080.       (let ((exp  (optimize (car exps))))
  1081.     (cond ((is-return-from-block? sym exp)
  1082.            ;; Any remaining clauses are dead code and should be removed.
  1083.            (if (not (null? (cdr exps)))
  1084.            (record-hack 'case-block-dead-code))
  1085.            (nreverse (cons exp result)))
  1086.           ((is-type? 'flic-and exp)
  1087.            ;; See if we can remove redundant tests.
  1088.            (push (maybe-simplify-and
  1089.                exp
  1090.                (look-for-redundant-tests (flic-and-exps exp) result))
  1091.              result)
  1092.            (optimize-case-block-exps sym (cdr exps) result))
  1093.           (else
  1094.            ;; No optimization possible.
  1095.            (optimize-case-block-exps sym (cdr exps) (cons exp result)))
  1096.           ))))
  1097.  
  1098.  
  1099. ;;; Look for case-block tests that are known to be either true or false
  1100. ;;; because of tests made in previous clauses.
  1101. ;;; For now, we only look at is-constructor tests.  Such a test is known
  1102. ;;; to be true if previous clauses have eliminated all other possible
  1103. ;;; constructors.  And such a test is known to be false if a previous
  1104. ;;; clause has already matched this constructor.
  1105.  
  1106. ;;; I added a test to ensure at least one is-constructor is preserved to
  1107. ;;; ensure strictness properties are maintained.  Jcp.
  1108.  
  1109. ;;; I added a check to avoid looking through long lists of previous clauses
  1110. ;;; that was croaking the optimizer on huge data types.   Jcp.
  1111.  
  1112. (define (look-for-redundant-tests exps previous-clauses)
  1113.   (if (null? exps)
  1114.       '()
  1115.    (if (> (length previous-clauses) 25)
  1116.        exps
  1117.       (let ((exp  (car exps)))
  1118.     (cond ((and (is-type? 'flic-is-constructor exp)
  1119.             previous-clauses  ; Always keep first clause - jcp
  1120.             (constructor-test-redundant? exp previous-clauses))
  1121.            ;; Known to be true.
  1122.            (record-hack 'case-block-discard-redundant-test)
  1123.            (cons (make-flic-pack (core-symbol "True"))
  1124.              (look-for-redundant-tests (cdr exps) previous-clauses)))
  1125.               ((and (is-type? 'flic-is-constructor exp)
  1126.             (constructor-test-duplicated? exp previous-clauses))
  1127.            ;; Known to be false.
  1128.            (record-hack 'case-block-discard-duplicate-test)
  1129.            (list (make-flic-pack (core-symbol "False"))))
  1130.           (else
  1131.            ;; No optimization.
  1132.            (cons exp
  1133.              (look-for-redundant-tests (cdr exps) previous-clauses)))
  1134.           )))))
  1135.  
  1136.  
  1137. ;;; In looking for redundant/duplicated tests, only worry about
  1138. ;;; is-constructor tests that have an argument that is a variable.
  1139. ;;; It's too hairy to consider any other cases.
  1140.  
  1141. (define (constructor-test-duplicated? exp previous-clauses)
  1142.   (let ((con  (flic-is-constructor-con exp))
  1143.     (arg  (flic-is-constructor-exp exp)))
  1144.     (and (is-type? 'flic-ref arg)
  1145.      (constructor-test-present? con arg previous-clauses))))
  1146.  
  1147. (define (constructor-test-redundant? exp previous-clauses)
  1148.   (let ((con     (flic-is-constructor-con exp))
  1149.         (arg     (flic-is-constructor-exp exp)))
  1150.     (and (is-type? 'flic-ref arg)
  1151.      (every-1 (lambda (c)
  1152.             (or (eq? c con)
  1153.             (constructor-test-present? c arg previous-clauses)))
  1154.           (algdata-constrs (con-alg con))))))
  1155.  
  1156. (define (constructor-test-present? con arg previous-clauses)
  1157.   (cond ((null? previous-clauses)
  1158.      '#f)
  1159.     ((constructor-test-present-1? con arg (car previous-clauses))
  1160.      '#t)
  1161.     (else
  1162.      (constructor-test-present? con arg (cdr previous-clauses)))))
  1163.  
  1164.  
  1165. ;;; The tricky thing here is that, even if the constructor test is 
  1166. ;;; present in the clause, we have to make sure that the entire clause won't
  1167. ;;; fail due to the presence of some other test which fails.  So look
  1168. ;;; for a very specific pattern here, namely
  1169. ;;;  (and (is-constructor con arg) (return-from ....))
  1170.  
  1171. (define (constructor-test-present-1? con arg clause)
  1172.   (and (is-type? 'flic-and clause)
  1173.        (let ((exps  (flic-and-exps clause)))
  1174.      (and (is-type? 'flic-is-constructor (car exps))
  1175.           (is-type? 'flic-return-from (cadr exps))
  1176.           (null? (cddr exps))
  1177.           (let* ((inner-exp  (car exps))
  1178.              (inner-con  (flic-is-constructor-con inner-exp))
  1179.              (inner-arg  (flic-is-constructor-exp inner-exp)))
  1180.         (and (eq? inner-con con)
  1181.              (flic-exp-eq? arg inner-arg)))))))
  1182.  
  1183.  
  1184.  
  1185. ;;; No fancy optimizations for return-from by itself.
  1186.  
  1187. (define-optimize flic-return-from (object)
  1188.   (setf (flic-return-from-exp object)
  1189.     (optimize (flic-return-from-exp object)))
  1190.   object)
  1191.  
  1192.  
  1193.  
  1194. ;;; Obvious simplification on if
  1195.  
  1196. (define-optimize flic-if (object)
  1197.   (let ((test-exp  (optimize (flic-if-test-exp object)))
  1198.     (then-exp  (optimize (flic-if-then-exp object)))
  1199.     (else-exp  (optimize (flic-if-else-exp object))))
  1200.     (cond ((and (is-type? 'flic-pack test-exp)
  1201.         (eq? (flic-pack-con test-exp) (core-symbol "True")))
  1202.        ;; Fold constant test
  1203.        (record-hack 'if-fold)
  1204.        then-exp)
  1205.       ((and (is-type? 'flic-pack test-exp)
  1206.         (eq? (flic-pack-con test-exp) (core-symbol "False")))
  1207.        ;; Fold constant test
  1208.        (record-hack 'if-fold)
  1209.        else-exp)
  1210.       ((and (is-type? 'flic-is-constructor test-exp)
  1211.         (eq? (flic-is-constructor-con test-exp) (core-symbol "True")))
  1212.        ;; Remove redundant is-constructor test.
  1213.        ;; Doing this as a general is-constructor identity
  1214.        ;; backfires because it prevents some of the important case-block
  1215.        ;; optimizations from being recognized, but it works fine here.
  1216.        (record-hack 'if-compress-test)
  1217.        (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
  1218.        (setf (flic-if-then-exp object) then-exp)
  1219.        (setf (flic-if-else-exp object) else-exp)
  1220.        object)
  1221.       ((and (is-type? 'flic-is-constructor test-exp)
  1222.         (eq? (flic-is-constructor-con test-exp) (core-symbol "False")))
  1223.        ;; Remove redundant is-constructor test, flip branches.
  1224.        (record-hack 'if-compress-test)
  1225.        (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
  1226.        (setf (flic-if-then-exp object) else-exp)
  1227.        (setf (flic-if-else-exp object) then-exp)
  1228.        object)
  1229.       ((and (is-type? 'flic-return-from then-exp)
  1230.         (is-type? 'flic-return-from else-exp)
  1231.         (eq? (flic-return-from-block-name then-exp)
  1232.              (flic-return-from-block-name else-exp)))
  1233.        ;; Hoist return-from outside of IF.
  1234.        ;; This may permit further case-block optimizations.
  1235.        (record-hack 'if-hoist-return-from)
  1236.        (let ((return-exp  then-exp))
  1237.          (setf (flic-if-test-exp object) test-exp)
  1238.          (setf (flic-if-then-exp object) (flic-return-from-exp then-exp))
  1239.          (setf (flic-if-else-exp object) (flic-return-from-exp else-exp))
  1240.          (setf (flic-return-from-exp return-exp) object)
  1241.          return-exp))
  1242.       ((and (is-type? 'flic-pack then-exp)
  1243.         (is-type? 'flic-pack else-exp)
  1244.         (eq? (flic-pack-con then-exp) (core-symbol "True"))
  1245.         (eq? (flic-pack-con else-exp) (core-symbol "False")))
  1246.        ;; This if does nothing useful at all!
  1247.        (record-hack 'if-identity)
  1248.        test-exp)
  1249.       ((and (is-type? 'flic-pack then-exp)
  1250.         (is-type? 'flic-pack else-exp)
  1251.         (eq? (flic-pack-con then-exp) (core-symbol "False"))
  1252.         (eq? (flic-pack-con else-exp) (core-symbol "True")))
  1253.        ;; Inverse of previous case
  1254.        (record-hack 'if-identity-inverse)
  1255.        (make-flic-is-constructor (core-symbol "False") test-exp))
  1256.       ((or (is-type? 'flic-lambda then-exp)
  1257.            (is-type? 'flic-lambda else-exp))
  1258.        ;; Hoist lambdas to surround entire if.  This allows us to
  1259.        ;; do a better job of saturating them.
  1260.        (record-hack 'if-hoist-lambda)
  1261.        (multiple-value-bind (vars then-exp else-exp)
  1262.            (do-if-hoist-lambda then-exp else-exp)
  1263.          (setf (flic-if-test-exp object) test-exp)
  1264.          (setf (flic-if-then-exp object) then-exp)
  1265.          (setf (flic-if-else-exp object) else-exp)
  1266.          (make-flic-lambda vars object)))
  1267.       ((is-strict2-app? test-exp)
  1268.        ;; Hoist strict2 to surround entire if.
  1269.        (record-hack 'if-hoist-strict2)
  1270.        (setf (flic-if-test-exp object) (strict2-app-arg2 test-exp))
  1271.        (setf (flic-if-then-exp object) then-exp)
  1272.        (setf (flic-if-else-exp object) else-exp)
  1273.        (make-strict2-app (strict2-app-arg1 test-exp) object))
  1274.       (else
  1275.        ;; No optimization possible
  1276.        (setf (flic-if-test-exp object) test-exp)
  1277.        (setf (flic-if-then-exp object) then-exp)
  1278.        (setf (flic-if-else-exp object) else-exp)
  1279.        object)
  1280.       )))
  1281.  
  1282.  
  1283.  
  1284. ;;; Try to pull as many variables as possible out to surround the entire
  1285. ;;; let.
  1286.  
  1287. (define (do-if-hoist-lambda then-exp else-exp)
  1288.   (let ((vars       '())
  1289.     (then-args  '())
  1290.     (else-args  '()))
  1291.     (do ((then-vars  (if (is-type? 'flic-lambda then-exp)
  1292.              (flic-lambda-vars then-exp)
  1293.              '())
  1294.              (cdr then-vars))
  1295.      (else-vars  (if (is-type? 'flic-lambda else-exp)
  1296.              (flic-lambda-vars else-exp)
  1297.              '())
  1298.              (cdr else-vars)))
  1299.     ((and (null? then-vars) (null? else-vars)) '#f)
  1300.     (let ((var  (init-flic-var (create-temp-var 'arg) '#f '#f)))
  1301.       (push var vars)
  1302.       (push (make-flic-ref var) then-args)
  1303.       (push (make-flic-ref var) else-args)))
  1304.     (values
  1305.       vars
  1306.       (if (is-type? 'flic-lambda then-exp)
  1307.       (do-lambda-to-let then-exp then-args)
  1308.       (make-flic-app then-exp then-args '#f))
  1309.       (if (is-type? 'flic-lambda else-exp)
  1310.       (do-lambda-to-let else-exp else-args)
  1311.       (make-flic-app else-exp else-args '#f)))))
  1312.  
  1313.     
  1314.  
  1315. ;;; Look for (sel (pack x)) => x
  1316.  
  1317. (define-optimize flic-sel (object)
  1318.   (optimize-flic-sel-aux object))
  1319.  
  1320. (define (optimize-flic-sel-aux object)
  1321.   (let ((new-exp  (optimize (flic-sel-exp object))))
  1322.     (setf (flic-sel-exp object) new-exp)
  1323.     (typecase new-exp
  1324.       (flic-ref
  1325.        ;; Check to see whether this is bound to a pack application
  1326.        (let ((val  (is-bound-to-constructor-app? (flic-ref-var new-exp))))
  1327.      (if val
  1328.          ;; Yup, it is.  Now extract the appropriate component,
  1329.          ;; provided it is inlineable.
  1330.          (let* ((i      (flic-sel-i object))
  1331.             (args   (flic-app-args val))
  1332.             (newval (list-ref args i)))
  1333.            (if (can-inline? newval '() '#t)
  1334.            (begin
  1335.              (record-hack 'sel-fold-var)
  1336.              (optimize (copy-flic-top newval)))
  1337.            object))
  1338.          ;; The variable was bound to something else.
  1339.          object)))
  1340.       (flic-app
  1341.        ;; The obvious optimization.
  1342.        (if (is-constructor-app-prim? new-exp)
  1343.        (begin
  1344.          (record-hack 'sel-fold-app)
  1345.          (list-ref (flic-app-args new-exp) (flic-sel-i object)))
  1346.        object))
  1347.       (else
  1348.        object))))
  1349.  
  1350.  
  1351.  
  1352.  
  1353. ;;; Do similar stuff for is-constructor.
  1354.  
  1355. (define-optimize flic-is-constructor (object)
  1356.   (let ((con      (flic-is-constructor-con object))
  1357.     (exp      (optimize (flic-is-constructor-exp object)))
  1358.     (exp-con  '#f))
  1359.     (cond ((algdata-tuple? (con-alg con))
  1360.        ;; Tuples have only one constructor, so this is always true.
  1361.        ;; But we can't get rid of the reference entirely because it
  1362.            ;; might change strictness.
  1363.        ;; Use strict2 to do this, which is kind of a grody hack.
  1364.        ;; All of the other optimizations dealing with strict2 are
  1365.        ;; just to allow this constant-folding to be happen
  1366.        ;; without losing track of the strictness properties.
  1367.        (record-hack 'is-constructor-fold-tuple)
  1368.        (make-strict2-app exp (make-flic-pack (core-symbol "True"))))
  1369.       ((setf exp-con (is-constructor-app? exp))
  1370.        ;; The expression is a constructor application.
  1371.        ;; *** Does this have similar strictness problems in the
  1372.        ;; *** presence of strict data constructors?
  1373.        (record-hack 'is-constructor-fold)
  1374.        (make-flic-pack
  1375.          (if (eq? exp-con con)
  1376.          (core-symbol "True")
  1377.          (core-symbol "False"))))
  1378.       (else
  1379.        ;; No optimization possible
  1380.        (setf (flic-is-constructor-exp object) exp)
  1381.        object))))
  1382.  
  1383. (define-optimize flic-con-number (object)
  1384.   (let ((exp  (flic-con-number-exp object))
  1385.     (type (flic-con-number-type object)))
  1386.     ;; ***Maybe ast-to-flic should look for this one.
  1387.     (if (algdata-tuple? type)
  1388.     (begin
  1389.       (record-hack 'con-number-fold-tuple)
  1390.       (make-flic-const 0))
  1391.     (let* ((new-exp  (optimize exp))
  1392.            (con      (is-constructor-app? new-exp)))
  1393.       (if con
  1394.           (begin
  1395.             (record-hack 'con-number-fold)
  1396.         (make-flic-const (con-tag con)))
  1397.           (begin
  1398.             (setf (flic-con-number-exp object) new-exp)
  1399.         object)))
  1400.       )))
  1401.  
  1402. (define-optimize flic-void (object)
  1403.   object)
  1404.  
  1405.  
  1406. (define-optimize flic-update (object)
  1407.   (let ((slots   (flic-update-slots object))
  1408.     (exp     (flic-update-exp object)))
  1409.     ;; Try to merge nested operators, discarding duplicate slot updates.
  1410.     ;; *** Maybe we should also look for nested let-expressions, etc.
  1411.     (when (is-type? 'flic-update exp)
  1412.       (record-hack 'update-compress)
  1413.       (let ((inner-slots  (flic-update-slots exp))
  1414.         (inner-exp    (flic-update-exp exp)))
  1415.     (dolist (s inner-slots)
  1416.       (unless (assv (car s) slots)
  1417.         (setf slots (nconc slots (list s)))))
  1418.     (setf exp inner-exp)))
  1419.     ;; Walk the slots
  1420.     (dolist (s slots)
  1421.       (setf (cdr s) (optimize (cdr s))))
  1422.     ;; Walk the subexp
  1423.     (setf (flic-update-exp object) (optimize exp))
  1424.     object))
  1425.  
  1426.  
  1427. ;;;===================================================================
  1428. ;;; General helper functions
  1429. ;;;===================================================================
  1430.  
  1431.  
  1432. ;;; Lucid's built-in every function seems to do a lot of unnecessary
  1433. ;;; consing.  This one is much faster.
  1434.  
  1435. (define (every-1 fn list)
  1436.   (cond ((null? list)
  1437.      '#t)
  1438.     ((funcall fn (car list))
  1439.      (every-1 fn (cdr list)))
  1440.     (else
  1441.      '#f)))
  1442.  
  1443.  
  1444.  
  1445. ;;; Equality predicate on flic expressions
  1446.  
  1447. (define (flic-exp-eq? a1 a2)
  1448.   (typecase a1
  1449.     (flic-const
  1450.      (and (is-type? 'flic-const a2)
  1451.       (equal? (flic-const-value a1) (flic-const-value a2))))
  1452.     (flic-ref
  1453.      (and (is-type? 'flic-ref a2)
  1454.       (eq? (flic-ref-var a1) (flic-ref-var a2))))
  1455.     (flic-pack
  1456.      (and (is-type? 'flic-pack a2)
  1457.       (eq? (flic-pack-con a1) (flic-pack-con a2))))
  1458.     (flic-sel
  1459.      (and (is-type? 'flic-sel a2)
  1460.       (eq? (flic-sel-con a1) (flic-sel-con a2))
  1461.       (eqv? (flic-sel-i a1) (flic-sel-i a2))
  1462.       (flic-exp-eq? (flic-sel-exp a1) (flic-sel-exp a2))))
  1463.     (else
  1464.      '#f)))
  1465.  
  1466.  
  1467.  
  1468. ;;; Predicates for testing whether an expression matches a pattern.
  1469.  
  1470. (define (is-constructor-app? exp)
  1471.   (typecase exp
  1472.     (flic-app
  1473.      ;; See if we have a saturated call to a constructor.
  1474.      (is-constructor-app-prim? exp))
  1475.     (flic-ref
  1476.      ;; See if we can determine anything about the value the variable
  1477.      ;; is bound to.
  1478.      (let ((value  (var-value (flic-ref-var exp))))
  1479.        (if value
  1480.        (is-constructor-app? value)
  1481.        '#f)))
  1482.     (flic-let
  1483.      ;; See if we can determine anything about the body of the let.
  1484.      (is-constructor-app? (flic-let-body exp)))
  1485.     (flic-pack
  1486.      ;; See if this is a nullary constructor.
  1487.      (let ((con  (flic-pack-con exp)))
  1488.        (if (eqv? (con-arity con) 0)
  1489.        con
  1490.        '#f)))
  1491.     (else
  1492.      '#f)))
  1493.  
  1494. (define (is-return-from-block? sym exp)
  1495.   (and (is-type? 'flic-return-from exp)
  1496.        (eq? (flic-return-from-block-name exp) sym)))
  1497.  
  1498. (define (is-constructor-app-prim? exp)
  1499.   (let ((fn    (flic-app-fn exp))
  1500.     (args  (flic-app-args exp)))
  1501.     (if (and (is-type? 'flic-pack fn)
  1502.          (eqv? (length args) (con-arity (flic-pack-con fn))))
  1503.     (flic-pack-con fn)
  1504.     '#f)))
  1505.  
  1506. (define (is-bound-to-constructor-app? var)
  1507.   (let ((val  (var-value var)))
  1508.     (if (and val
  1509.          (is-type? 'flic-app val)
  1510.          (is-constructor-app-prim? val))
  1511.     val
  1512.     '#f)))
  1513.  
  1514. (define (is-selector? con i exp)
  1515.   (or (and (is-type? 'flic-ref exp)
  1516.        (is-selector? con i (var-value (flic-ref-var exp))))
  1517.       (and (is-type? 'flic-sel exp)
  1518.        (eq? (flic-sel-con exp) con)
  1519.        (eqv? (the fixnum i) (the fixnum (flic-sel-i exp)))
  1520.        (flic-sel-exp exp))
  1521.       ))
  1522.  
  1523. (define (is-selector-list? con i subexp exps)
  1524.   (declare (type fixnum i))
  1525.   (if (null? exps)
  1526.       subexp
  1527.       (let ((temp  (is-selector? con i (car exps))))
  1528.     (and (flic-exp-eq? subexp temp)
  1529.          (is-selector-list? con (+ 1 i) subexp (cdr exps))))))
  1530.  
  1531.  
  1532.  
  1533. ;;;===================================================================
  1534. ;;; Inlining criteria
  1535. ;;;===================================================================
  1536.  
  1537. ;;; Expressions that can be inlined unconditionally are constants, variable
  1538. ;;; references, and some functions.
  1539. ;;; I've made some attempt here to arrange the cases in the order they
  1540. ;;; are likely to occur.
  1541.  
  1542. (define (can-inline? exp recursive-vars toplevel?)
  1543.   (typecase exp
  1544.     (flic-sel
  1545.      ;; Listed first because it happens more frequently than
  1546.      ;; anything else.
  1547.      ;; *** Inlining these is an experiment.
  1548.      ;; *** This transformation interacts with the strictness
  1549.      ;; *** analyzer; if the variable referenced is not strict, then
  1550.      ;; *** it is probably not a good thing to do since it adds extra
  1551.      ;; *** forces.
  1552.      ;; (let ((subexp  (flic-sel-exp exp)))
  1553.      ;;   (and (is-type? 'flic-ref subexp)
  1554.      ;;        (not (memq (flic-ref-var subexp) recursive-vars))))
  1555.      '#f)
  1556.     (flic-lambda
  1557.      ;; Do not try to inline lambdas if the fancy inline optimization
  1558.      ;; is disabled.
  1559.      ;; Watch for problems with infinite loops with recursive variables.
  1560.      (if (dynamic *do-inline-optimizations*)
  1561.      (simple-function-body? (flic-lambda-body exp)
  1562.                 (flic-lambda-vars exp)
  1563.                 recursive-vars
  1564.                 toplevel?)
  1565.      '#f))
  1566.     (flic-ref
  1567.      ;; We get into infinite loops trying to inline recursive variables.
  1568.      (not (memq (flic-ref-var exp) recursive-vars)))
  1569.     ((or flic-pack flic-const)
  1570.      '#t)
  1571.     (else
  1572.      '#f)))
  1573.  
  1574.  
  1575. ;;; Determining whether to inline a function is difficult.  This is
  1576. ;;; very conservative to avoid code bloat.  What we need to do is
  1577. ;;; compare the cost (in program size mainly) of the inline call with
  1578. ;;; an out of line call.  For an out of line call, we pay for one function
  1579. ;;; call and a setup for each arg.  When inlining, we pay for function
  1580. ;;; calls in the body and for args referenced more than once.  In terms of
  1581. ;;; execution time, we win big when a functional parameter is called
  1582. ;;; since this `firstifies' the program.
  1583.  
  1584. ;;; Here's the criteria:
  1585. ;;;  An inline function gets to reference no more that 2 non-parameter
  1586. ;;;  values (including constants and repeated parameter references).
  1587. ;;; For non-toplevel functions, be slightly more generous since the
  1588. ;;; fixed overhead of binding the local function would go away.
  1589.  
  1590. (define (simple-function-body? exp lambda-vars recursive-vars toplevel?)
  1591.   (let ((c  (if toplevel? 2 4)))
  1592.     (>= (the fixnum (simple-function-body-1 exp lambda-vars recursive-vars c))
  1593.     0)))
  1594.  
  1595.  
  1596. ;;; I've made some attempt here to order the cases by how frequently
  1597. ;;; they appear.
  1598.  
  1599. (define (simple-function-body-1 exp lambda-vars recursive-vars c)
  1600.   (declare (type fixnum c))
  1601.   (if (< c 0)
  1602.       (values c '())
  1603.       (typecase exp
  1604.     (flic-ref
  1605.      (let ((var (flic-ref-var exp)))
  1606.        (cond ((memq var lambda-vars)
  1607.           (values c (list-remove-1 var lambda-vars)))
  1608.          ((memq var recursive-vars)
  1609.           (values -1 '()))
  1610.          (else
  1611.           (values (the fixnum (1- c)) lambda-vars)))))
  1612.     (flic-app
  1613.      (simple-function-body-1/l
  1614.        (cons (flic-app-fn exp) (flic-app-args exp))
  1615.        lambda-vars recursive-vars c))
  1616.     (flic-sel
  1617.      (simple-function-body-1
  1618.       (flic-sel-exp exp)
  1619.       lambda-vars recursive-vars (the fixnum (1- c))))
  1620.     (flic-is-constructor
  1621.      (simple-function-body-1
  1622.       (flic-is-constructor-exp exp)
  1623.       lambda-vars recursive-vars (the fixnum (1- c))))
  1624.     ((or flic-const flic-pack)
  1625.      (values (the fixnum (1- c)) lambda-vars))
  1626.     (else
  1627.          ;; case & let & lambda not allowed.
  1628.      (values -1 '())))))
  1629.  
  1630. (define (list-remove-1 item list)
  1631.   (cond ((null? list)
  1632.      '())
  1633.     ((eq? item (car list))
  1634.      (cdr list))
  1635.     (else
  1636.      (cons (car list) (list-remove-1 item (cdr list))))
  1637.     ))
  1638.  
  1639. (define (simple-function-body-1/l exps lambda-vars recursive-vars c)
  1640.   (declare (type fixnum c))
  1641.   (if (or (null? exps) (< c 0))
  1642.       (values c lambda-vars)
  1643.       (multiple-value-bind (c-1 lambda-vars-1)
  1644.       (simple-function-body-1 (car exps) lambda-vars recursive-vars c)
  1645.     (simple-function-body-1/l
  1646.       (cdr exps) lambda-vars-1 recursive-vars c-1))))
  1647.  
  1648.  
  1649.  
  1650. ;;;===================================================================
  1651. ;;; Constant structured data detection
  1652. ;;;===================================================================
  1653.  
  1654.  
  1655. ;;; Look to determine whether an object is a structured constant,
  1656. ;;; recursively examining its components if it's an app.  This is
  1657. ;;; necessary in order to detect constants with arbitrary circular
  1658. ;;; reference to the vars in recursive-vars.
  1659.  
  1660. (define (structured-constant-recursive? object recursive-vars stack)
  1661.   (typecase object
  1662.     (flic-const
  1663.      '#t)
  1664.     (flic-ref
  1665.      (let ((var  (flic-ref-var object)))
  1666.        (or (memq var stack)
  1667.        (var-toplevel? var)
  1668.        (and (memq var recursive-vars)
  1669.         (structured-constant-recursive?
  1670.          (var-value var) recursive-vars (cons var stack))))))
  1671.     (flic-pack
  1672.      '#t)
  1673.     (flic-app
  1674.      (structured-constant-app-recursive?
  1675.        (flic-app-fn object)
  1676.        (flic-app-args object)
  1677.        recursive-vars
  1678.        stack))
  1679.     (flic-lambda
  1680.      (lambda-hoistable? object))
  1681.     (else
  1682.      '#f)))
  1683.  
  1684. (define (structured-constant-app-recursive? fn args recursive-vars stack)
  1685.   (and (is-type? 'flic-pack fn)
  1686.        (eqv? (length args) (con-arity (flic-pack-con fn)))
  1687.        (every-1 (lambda (a)
  1688.           (structured-constant-recursive? a recursive-vars stack))
  1689.         args)))
  1690.  
  1691.  
  1692. ;;; Here's a non-recursive (and more efficient) version of the above.
  1693. ;;; Instead of looking at the whole structure, it only looks one level
  1694. ;;; deep.  This can't detect circular constants, but is useful in
  1695. ;;; contexts where circularities cannot appear.
  1696.  
  1697. (define (structured-constant? object)
  1698.   (typecase object
  1699.     (flic-ref
  1700.      (var-toplevel? (flic-ref-var object)))
  1701.     (flic-const
  1702.      '#t)
  1703.     (flic-pack
  1704.      '#t)
  1705.     (flic-lambda
  1706.      (lambda-hoistable? object))
  1707.     (else
  1708.      '#f)))
  1709.  
  1710. (define (structured-constant-app? fn args)
  1711.   (and (is-type? 'flic-pack fn)
  1712.        (eqv? (length args) (con-arity (flic-pack-con fn)))
  1713.        (every-1 (function structured-constant?) args)))
  1714.  
  1715.  
  1716. ;;; Determine whether a lambda can be hoisted to top-level.
  1717. ;;; The main purpose of this code is to mark structured constants
  1718. ;;; containing simple lambdas to permit later folding of sel expressions 
  1719. ;;; on those constants.  Since the latter expression is permissible
  1720. ;;; only on inlinable functions, stop if we hit an expression that
  1721. ;;; would make the function not inlinable.
  1722.  
  1723. (define (lambda-hoistable? object)
  1724.   (and (can-inline? object '() '#t)
  1725.        (lambda-hoistable-aux
  1726.      (flic-lambda-body object)
  1727.      (flic-lambda-vars object))))
  1728.  
  1729. (define (lambda-hoistable-aux object local-vars)
  1730.   (typecase object
  1731.     (flic-ref
  1732.      (or (var-toplevel? (flic-ref-var object))
  1733.      (memq (flic-ref-var object) local-vars)))
  1734.     ((or flic-const flic-pack)
  1735.      '#t)
  1736.     (flic-sel
  1737.      (lambda-hoistable-aux (flic-sel-exp object) local-vars))
  1738.     (flic-is-constructor
  1739.      (lambda-hoistable-aux (flic-is-constructor-exp object) local-vars))
  1740.     (flic-app
  1741.      (and (lambda-hoistable-aux (flic-app-fn object) local-vars)
  1742.       (every-1 (lambda (x) (lambda-hoistable-aux x local-vars))
  1743.            (flic-app-args object))))
  1744.     (else
  1745.      '#f)))
  1746.  
  1747.  
  1748. ;;; Having determined that something is a structured constant,
  1749. ;;; enter it (and possibly its subcomponents) in the hash table
  1750. ;;; and return a var-ref.
  1751.  
  1752. (define (enter-structured-constant value recursive?)
  1753.   (multiple-value-bind (con args var)
  1754.       (enter-structured-constant-aux value recursive?)
  1755.     (when (not var)
  1756.       (setf var (create-temp-var 'constant))
  1757.       (add-new-structured-constant var con args))
  1758.     (make-flic-ref var)))
  1759.  
  1760. (define (enter-structured-constant-aux value recursive?)
  1761.   (let* ((fn   (flic-app-fn value))
  1762.      (con  (flic-pack-con fn))
  1763.      (args (if recursive?
  1764.            (map (function enter-structured-constant-arg)
  1765.             (flic-app-args value))
  1766.            (flic-app-args value))))
  1767.     (values con args (lookup-structured-constant con args))))
  1768.  
  1769. (define (enter-structured-constant-arg a)
  1770.   (if (is-type? 'flic-app a)
  1771.       (enter-structured-constant a '#t)
  1772.       a))
  1773.  
  1774. (define (lookup-structured-constant con args)
  1775.   (lookup-structured-constant-aux
  1776.     (table-entry *structured-constants-table* con) args))
  1777.  
  1778. (define (lookup-structured-constant-aux alist args)
  1779.   (cond ((null? alist)
  1780.      '#f)
  1781.     ((every (function flic-exp-eq?) (car (car alist)) args)
  1782.      (cdr (car alist)))
  1783.     (else
  1784.      (lookup-structured-constant-aux (cdr alist) args))))
  1785.  
  1786. (define (add-new-structured-constant var con args)
  1787.   (push (cons args var) (table-entry *structured-constants-table* con))
  1788.   (setf (var-toplevel? var) '#t)
  1789.   (setf (var-value var) (make-flic-app (make-flic-pack con) args '#t))
  1790.   (push var *structured-constants*)
  1791.   var)
  1792.  
  1793.  
  1794.  
  1795. ;;;===================================================================
  1796. ;;; Invariant argument stuff
  1797. ;;;===================================================================
  1798.  
  1799.  
  1800. ;;; When processing a saturated call to a locally defined function,
  1801. ;;; note whether any of the arguments are always passed the same value.
  1802.  
  1803. (define (note-invariant-args args vars)
  1804.   (when (and (not (null? args)) (not (null? vars)))
  1805.     (let* ((arg  (car args))
  1806.        (var  (car vars))
  1807.        (val  (var-arg-invariant-value var)))
  1808.       (cond ((not (var-arg-invariant? var))
  1809.          ;; This argument already marked as having more than one
  1810.          ;; value.
  1811.          )
  1812.         ((and (is-type? 'flic-ref arg)
  1813.           (eq? (flic-ref-var arg) var))
  1814.          ;; This is a recursive call with the same argument.
  1815.          ;; Don't update the arg-invariant-value slot.
  1816.          )
  1817.         ((or (not val)
  1818.          (flic-exp-eq? arg val))
  1819.          ;; Either this is the first call, or a second call with
  1820.          ;; the same argument.
  1821.          (setf (var-arg-invariant-value var) arg))
  1822.         (else
  1823.          ;; Different values for this argument are passed in
  1824.          ;; different places, so we can't mess with it.
  1825.          (setf (var-arg-invariant? var) '#f)))
  1826.       (note-invariant-args (cdr args) (cdr vars)))))
  1827.  
  1828.  
  1829. ;;; After processing a let form, check to see if any of the bindings
  1830. ;;; are for local functions with invariant arguments.
  1831. ;;; Suppose we have something like
  1832. ;;;   let foo = \ x y z -> <fn-body>
  1833. ;;;     in <let-body>
  1834. ;;; and y is known to be invariant; then we rewrite this as
  1835. ;;;   let foo1 = \ x z -> let y = <invariant-value> in <fn-body>
  1836. ;;;       foo = \ x1 y1 z1 -> foo1 x1 z1
  1837. ;;;     in <let-body>
  1838. ;;; The original foo binding is inlined on subsequent passes and 
  1839. ;;; should go away.  Likewise, the binding of y should be inlined also.
  1840. ;;; *** This is kind of bogus because of the way it depends on the
  1841. ;;; *** magic inline bit.  It would be better to do a code walk
  1842. ;;; *** now on the entire let expression to rewrite all the calls to foo.
  1843.  
  1844. (define (add-stuff-for-invariants bindings)
  1845.   (if (null? bindings)
  1846.       '()
  1847.       (let* ((var  (car bindings))
  1848.          (val  (var-value var)))
  1849.     (setf (cdr bindings)
  1850.           (add-stuff-for-invariants (cdr bindings)))
  1851.     (if (and (is-type? 'flic-lambda val)
  1852.          ;; Don't mess with single-reference variable bindings,
  1853.          ;; or things we are going to inline anyway.
  1854.          (not (var-single-ref var))
  1855.          (not (var-simple? var))
  1856.          ;; All references must be in saturated calls to do this.
  1857.          (eqv? (var-referenced var) (var-fn-referenced var))
  1858.          ;; There is at least one argument marked invariant.
  1859.          (some (function var-arg-invariant?) (flic-lambda-vars val))
  1860.          ;; Every argument marked invariant must also be hoistable.
  1861.          (every-1 (function arg-hoistable?) (flic-lambda-vars val)))
  1862.         (hoist-invariant-args
  1863.           var
  1864.           val
  1865.           bindings)
  1866.         bindings))))
  1867.  
  1868. (define (arg-hoistable? var)
  1869.   (if (var-arg-invariant? var)
  1870.       (or (not (var-arg-invariant-value var))
  1871.       (flic-invariant? (var-arg-invariant-value var)
  1872.                (dynamic *local-bindings*)))
  1873.       '#t))
  1874.  
  1875. (define (hoist-invariant-args var val bindings)
  1876.   (let ((foo1-var       (copy-temp-var (def-name var)))
  1877.     (foo1-def-vars  '())
  1878.     (foo1-app-args  '())
  1879.     (foo1-let-vars  '())
  1880.     (foo-def-vars   '()))
  1881.     (push foo1-var bindings)
  1882.     (dolist (v (flic-lambda-vars val))
  1883.       (let ((new-v  (copy-temp-var (def-name v))))
  1884.     (push (init-flic-var new-v '#f '#f) foo-def-vars)
  1885.     (if (var-arg-invariant? v)
  1886.         (when (var-arg-invariant-value v)
  1887.           (push (init-flic-var
  1888.               v (copy-flic-top (var-arg-invariant-value v)) '#f)
  1889.             foo1-let-vars))
  1890.         (begin
  1891.           (push v foo1-def-vars)
  1892.           (push (make-flic-ref new-v) foo1-app-args))
  1893.       )))
  1894.     (setf foo1-def-vars (nreverse foo1-def-vars))
  1895.     (setf foo1-app-args (nreverse foo1-app-args))
  1896.     (setf foo1-let-vars (nreverse foo1-let-vars))
  1897.     (setf foo-def-vars (nreverse foo-def-vars))
  1898.     (record-hack 'let-hoist-invariant-args var foo1-let-vars)
  1899.     ;; Fix up the value of foo1
  1900.     (init-flic-var
  1901.       foo1-var
  1902.       (let ((body  (make-flic-let foo1-let-vars (flic-lambda-body val) '#f)))
  1903.     (if (null? foo1-def-vars)
  1904.         ;; *All* of the arguments were invariant.
  1905.         body
  1906.         ;; Otherwise, make a new lambda
  1907.         (make-flic-lambda foo1-def-vars body)))
  1908.       '#f)
  1909.     ;; Fix up the value of foo and arrange for it to be inlined.
  1910.     (setf (flic-lambda-vars val) foo-def-vars)
  1911.     (setf (flic-lambda-body val)
  1912.       (if (null? foo1-app-args)
  1913.           (make-flic-ref foo1-var)
  1914.           (make-flic-app (make-flic-ref foo1-var) foo1-app-args '#t)))
  1915.     (setf (var-simple? var) '#t)
  1916.     (setf (var-inline? var) '#t)
  1917.     ;; Return modified list of bindings
  1918.     bindings))
  1919.  
  1920.  
  1921.  
  1922. ;;;===================================================================
  1923. ;;; Install globals
  1924. ;;;===================================================================
  1925.  
  1926.  
  1927. ;;; The optimizer, CFN, etc. can introduce new top-level variables that
  1928. ;;; are not installed in the symbol table.  This causes problems if
  1929. ;;; those variables are referenced in the .hci file (as in the inline
  1930. ;;; expansion of some other variables).  So we need to fix up the 
  1931. ;;; symbol table before continuing.
  1932.  
  1933. (define (install-uninterned-globals vars)
  1934.   (dolist (v vars)
  1935.     (let* ((module  (locate-module (def-module v)))
  1936.        (name    (def-name v))
  1937.        (table   (module-symbol-table module))
  1938.        (def     (table-entry table name)))
  1939.       (cond ((not def)
  1940.          ;; This def was not installed.  Rename it if it's a gensym
  1941.          ;; and install it.
  1942.          (when (gensym? name)
  1943.            (setf name (rename-gensym-var v name table)))
  1944.          (setf (table-entry table name) v))
  1945.         ((eq? def v)
  1946.          ;; Already installed.
  1947.          '#t)
  1948.         (else
  1949.          ;; Ooops!  The symbol installed in the symbol table isn't 
  1950.              ;; this one!
  1951.          (error "Duplicate defs ~s and ~s in symbol table for ~s!"
  1952.             v def module))
  1953.         ))))
  1954.  
  1955.  
  1956. (define (rename-gensym-var var name table)
  1957.   (setf name (string->symbol (symbol->string name)))
  1958.   (if (table-entry table name)
  1959.       ;; This name already in use; gensym a new one!
  1960.       (rename-gensym-var var (gensym (symbol->string name)) table)
  1961.       ;; OK, no problem
  1962.       (setf (def-name var) name)))
  1963.  
  1964.  
  1965.  
  1966. ;;;===================================================================
  1967. ;;; Postoptimizer
  1968. ;;;===================================================================
  1969.  
  1970. ;;; This is another quick traversal of the structure to determine 
  1971. ;;; whether references to functions are fully saturated or not.
  1972. ;;; Also makes sure that reference counts on variables are correct;
  1973. ;;; this is needed so the code generator can generate ignore declarations
  1974. ;;; for unused lambda variables.
  1975.  
  1976. (define-flic-walker postoptimize (object))
  1977.  
  1978. (define-postoptimize flic-lambda (object)
  1979.   (dolist (var (flic-lambda-vars object))
  1980.     (setf (var-referenced var) 0))
  1981.   (postoptimize (flic-lambda-body object)))
  1982.  
  1983. (define-postoptimize flic-let (object)
  1984.   (dolist (var (flic-let-bindings object))
  1985.     (setf (var-referenced var) 0)
  1986.     (let ((val  (var-value var)))
  1987.       (setf (var-arity var)
  1988.         (if (is-type? 'flic-lambda val)
  1989.         (length (flic-lambda-vars val))
  1990.         0))))
  1991.   (dolist (var (flic-let-bindings object))
  1992.     (postoptimize (var-value var)))
  1993.   (postoptimize (flic-let-body object)))
  1994.  
  1995. (define-postoptimize flic-app (object)
  1996.   (let ((fn    (flic-app-fn object)))
  1997.     (typecase fn
  1998.       (flic-ref
  1999.        (let* ((var     (flic-ref-var fn))
  2000.           (arity   (var-arity var)))
  2001.      (if (not (var-toplevel? var)) (incf (var-referenced var)))
  2002.      (when (not (eqv? arity 0))
  2003.        (postoptimize-app-aux object var arity (flic-app-args object)))))
  2004.       (flic-pack
  2005.        (let* ((con    (flic-pack-con fn))
  2006.           (arity  (con-arity con)))
  2007.      (postoptimize-app-aux object '#f arity (flic-app-args object))))
  2008.       (else
  2009.        (postoptimize fn)))
  2010.     (dolist (a (flic-app-args object))
  2011.       (postoptimize a))))
  2012.  
  2013. (define (postoptimize-app-aux object var arity args)
  2014.   (declare (type fixnum arity))
  2015.   (let ((nargs   (length args)))
  2016.     (declare (type fixnum nargs))
  2017.     (cond ((< nargs arity)
  2018.        ;; not enough arguments
  2019.        (when var (setf (var-standard-refs? var) '#t)))
  2020.       ((eqv? nargs arity)
  2021.        ;; exactly the right number of arguments
  2022.        (when var (setf (var-optimized-refs? var) '#t))
  2023.        (setf (flic-app-saturated? object) '#t))
  2024.       (else
  2025.        ;; make the fn a nested flic-app
  2026.        (multiple-value-bind (arghead argtail)
  2027.            (split-list args arity)
  2028.          (setf (flic-app-fn object)
  2029.            (make-flic-app (flic-app-fn object) arghead '#t))
  2030.          (setf (flic-app-args object) argtail)
  2031.          (when var (setf (var-optimized-refs? var) '#t))
  2032.          (dolist (a arghead)
  2033.            (postoptimize a))))
  2034.       )))
  2035.  
  2036. (define-postoptimize flic-ref (object)
  2037.   (let ((var  (flic-ref-var object)))
  2038.     (if (not (var-toplevel? var)) (incf (var-referenced var)))
  2039.     (setf (var-standard-refs? var) '#t)))
  2040.  
  2041. (define-postoptimize flic-const (object)
  2042.   object)
  2043.  
  2044. (define-postoptimize flic-pack (object)
  2045.   object)
  2046.  
  2047. (define-postoptimize flic-and (object)
  2048.   (for-each (function postoptimize) (flic-and-exps object)))
  2049.  
  2050. (define-postoptimize flic-case-block (object)
  2051.   (for-each (function postoptimize) (flic-case-block-exps object)))
  2052.  
  2053. (define-postoptimize flic-if (object)
  2054.   (postoptimize (flic-if-test-exp object))
  2055.   (postoptimize (flic-if-then-exp object))
  2056.   (postoptimize (flic-if-else-exp object)))
  2057.  
  2058. (define-postoptimize flic-return-from (object)
  2059.   (postoptimize (flic-return-from-exp object)))
  2060.  
  2061. (define-postoptimize flic-sel (object)
  2062.   (postoptimize (flic-sel-exp object)))
  2063.  
  2064. (define-postoptimize flic-is-constructor (object)
  2065.   (postoptimize (flic-is-constructor-exp object)))
  2066.  
  2067. (define-postoptimize flic-con-number (object)
  2068.   (postoptimize (flic-con-number-exp object)))
  2069.  
  2070. (define-postoptimize flic-void (object)
  2071.   object)
  2072.  
  2073. (define-postoptimize flic-update (object)
  2074.   (dolist (s (flic-update-slots object))
  2075.     (postoptimize (cdr s)))
  2076.   (setf (flic-update-slots object)
  2077.     (sort-list (flic-update-slots object)
  2078.            (lambda (s1 s2)
  2079.              (< (the fixnum (car s1)) (the fixnum (car s2))))))
  2080.   (postoptimize (flic-update-exp object)))
  2081.